#! /usr/bin/env perl

###########################################################################
#
# vrel
#
###########################################################################
#
# This command releases files to production based on information in the config file (typically
# /usr/local/etc/VCtools.conf).  Files must be committed before they can be released.
#
# #########################################################################
#
# All the code herein is released under the Artistic License
#		( http://www.perl.com/language/misc/Artistic.html )
# Copyright (c) 2003-2008 Barefoot Software, Copyright (c) 2004-2007 ThinkGeek
#
###########################################################################

use strict;
use warnings;

use VCtools::Base;
use VCtools::Args;
use VCtools::Common;


sub needs_to_be_released();

# dispatch tables for release methods
our $dispatch =
{
	local	=>	{
					get_mtime	=>	\&local_mtime,
					rm_file		=>	\&local_rm,
					cp_file		=>	\&local_cp,
					fix_group	=>	\&local_chgrp,
				},
	rsh		=>	{
					get_mtime	=>	\&rsh_mtime,
					rm_file		=>	\&rsh_rm,
					cp_file		=>	\&rcp,
					fix_group	=>	\&rsh_chgrp,
				},
	ssh		=>	{
					get_mtime	=>	\&ssh_mtime,
					rm_file		=>	\&ssh_rm,
					cp_file		=>	\&scp,
					fix_group	=>	\&ssh_chgrp,
				},
};


#################################
# OPTIONS AND ARGUMENTS
#################################

VCtools::switch('info_only', 'I', 'only show release information');
VCtools::switch('force', 'f', "release files even if not checked in (doesn't work with -d) /dangerous!/");
VCtools::switch('determine', 'd', 'determine (recursively) which files to release (only if released previously)');
VCtools::args('files', 'optlist', 'file(s) to release (with -d defaults to . ; without -d may not be omitted)');
VCtools::getopts();

my @files = VCtools::files();


#################################
# CHECK FOR ERRORS
#################################

VCtools::fatal_error("files to release must be specified unless -d is used")
		if not VCtools::determine() and not VCtools::files();

@files = ('.') unless @files;

our $proj = VCtools::verify_files_and_group(@files);

# can't release a directory (at least at this time)
# however, directories are okay with -d
if (not VCtools::determine() and grep { -d } @files)
{
	VCtools::fatal_error("can only release files (not directories)");
}

# need a valid release method
our $rmethod = VCtools::get_proj_directive($proj, ReleaseMethod => '<none specified>');
VCtools::fatal_error("unknown release method $rmethod") unless exists $dispatch->{$rmethod};

unless (VCtools::determine())
{
	# get statuses for everything at once (quicker that way)
	VCtools::cache_file_status(@files, { DONT_RECURSE => 1 });

	# all files must have status "nothing"
	# any other status should block release
	# quick method for checking this: number of files with status 'nothing'
	# should exactly == total number of files
	unless (@files == VCtools::get_all_with_status('nothing'))
	{
		if (VCtools::force())
		{
			my %nothings = map { $_ => 1 } VCtools::get_all_with_status('nothing');
			foreach (@files)
			{
				next if exists $nothings{$_};

				if (VCtools::modified_from_vc($_))
				{
					VCtools::prompt_to_continue("File $_ is not checked in!");
				}
				elsif (VCtools::outdated_by_vc($_))
				{
					VCtools::prompt_to_continue("File $_ has a newer version in VC!");
				}
				else
				{
					VCtools::fatal_error("can't figure out what's wrong with file $_");
				}
			}
		}
		else
		{
			VCtools::fatal_error("not all files are properly checked in");
		}
	}

=not_working_with_svn_yet
	# probably _shouldn't_ release it if anyone else has it checked out
	if (cvs::lockers($module))
	{
		print STDERR "$me: others have this module checked out\n";
		exit 1 unless get_yn("Release it anyway?");
	}

	# write access to the file is suspicious enough to vomit on
	if (-w $module)
	{
		print STDERR "$me: won't release a file unless it is read-only\n";
		print STDERR "  (check permissions and run cdiff)\n";
		exit 1;
	}
=cut
}



#################################
# MAIN
#################################


if (VCtools::determine())
{
	# have to call cache_file_status() instead of get_all_files() because needs_to_be_released calls modififed_from_vc()
	# obviously we want to force recursion here (and since we don't really have a -r switch, this would crash if we
	# didn't provide a DONT_RECURSE option)
	@files = VCtools::cache_file_status(@files, { DONT_RECURSE => 0 });

	@files = grep { needs_to_be_released } @files;
	if (@files)
	{
		VCtools::list_files("need to be released", @files);
		exit unless VCtools::yesno("Proceed with release(s)?");
	}
	else
	{
		print "\n";
		VCtools::info_msg("no files were found that should be released");
		exit;
	}
}

foreach my $file (@files)
{
	my $rpath = VCtools::release_path($file);
	VCtools::fatal_error("don't have a release path for $file") unless $rpath;

	VCtools::info_msg(VCtools::info_only() ? "release info for" : "releasing",
			"file $file ...");

	unless (defined release($file, $rpath))
	{
		VCtools::prompt_to_continue("release of $file to $rpath failed!");
	}
}

print "\ndone\n";


#################################
# SUBS
#################################


# return values:
#	1: VC file is newer than prod file
#	0: VC file and prod file have same date
#	-1: VC file is older than prod file
#	undef: prod file doesn't exist
sub cmp_dates
{
	my ($vc_file, $machine, $prod_path) = @_;

	my $vc_date = (stat $vc_file)[9];
	my $prod_file_date = $dispatch->{$rmethod}->{get_mtime}->($machine, $prod_path);
	print STDERR "comparing prod date $prod_file_date to vc date $vc_date\n" if DEBUG >= 4;

	return $prod_file_date == 0 ? undef : $vc_date <=> $prod_file_date;
}


# return value:
#	true: file was successfully released
#	false: file was not released with user approval
#	undef: system error while trying to release
sub release
{
	my ($file, $rpath) = @_;
	my $machine = $rpath =~ s/^(\w+):// ? $1 : "localhost";
	print STDERR "production file is $rpath\n" if DEBUG >= 2;

	VCtools::info_msg(-INDENT => VCtools::info_only() ? "on:" : "now releasing to:", $machine, "path", $rpath);

	# make sure existing file is older
	my $cmp = cmp_dates($file, $machine, $rpath);
	if (VCtools::info_only())
	{
		if (not defined $cmp)
		{
			VCtools::info_msg(-INDENT => "file does not yet exist in production",
					"(needs to be released)");
		}
		elsif ($cmp == 0)
		{
			VCtools::info_msg(-INDENT => "production file has same date; no need to release");
		}
		elsif ($cmp == -1)
		{
			VCtools::info_msg(-INDENT => "production file is newer; check for unauthorized modification");
		}
		else					# file in production is indeed older
		{
			VCtools::info_msg(-INDENT => "production file is old; need to release");
		}
		return 1;
	}
	unless (not defined $cmp or $cmp == 1)
	{
		VCtools::info_msg(-INDENT => "current production file is",
				$cmp == 0 ? "the same age as" : "newer than", "the development file");
		return 0 unless VCtools::yesno("Release it anyway?");
	}

	# if pretending, no need to go further
	if (VCtools::pretend())
	{
		VCtools::info_msg(-OFFSET => "would execute:", "release-method-specific commands to rm, cp, and chgrp");
	}

	# remove old file
	$dispatch->{$rmethod}->{rm_file}->($machine, $rpath);

	# copy new file
	VCtools::info_msg(-INDENT => "copying $file to $rpath") if VCtools::verbose();
	$dispatch->{$rmethod}->{cp_file}->($machine, $file, $rpath);

	# make sure file has the correct group
	my $group = VCtools::project_group($proj);
	VCtools::info_msg(-INDENT => "changing group on $file to $group") if VCtools::verbose();
	$dispatch->{$rmethod}->{fix_group}->($machine, $rpath, $group);

	# successfully released
	return 1;
}


sub needs_to_be_released ()
{
	# we expect filename to be in $_

	# never try to release dirs
	return 0 if -d;

	my $rpath = VCtools::release_path($_);
	return 0 unless $rpath;

	my $machine = $rpath =~ s/^(\w+):// ? $1 : "localhost";
	my $cmp = cmp_dates($_, $machine, $rpath);
	return 0 unless defined $cmp;							# if no production file, don't try to release it
	if ($cmp == 1)
	{
		if (VCtools::modified_from_vc($_))
		{
			# can't release stuff that isn't checked in
			VCtools::info_msg("$_ would be releaseable if it were checked in");
			return 0;
		}

		# else it's newer than production so should be released
		return 1;
	}

	# if we get here, production is the same age as (or newer than, for some bizarre reason), so don't release
	return 0;
}


sub local_mtime
{
	return (stat($_[1]))[9] || 0;
}

sub rsh_mtime
{
	return `rsh $_[0] perl -e 'print (stat(\$ARGV[0]))[9] || 0' $_[1]`;
}

sub ssh_mtime
{
	return `ssh $_[0] perl -e 'print (stat(\$ARGV[0]))[9] || 0' $_[1]`;
}


sub local_rm
{
	unlink($_[1]);
}

sub rsh_rm
{
	my $v = VCtools::verbose() ? "-v" : "";
	system("rsh $_[0] /bin/rm $v -f $_[1]");
}

sub ssh_rm
{
	my $v = VCtools::verbose() ? "-v" : "";
	system("ssh $_[0] /bin/rm $v -f $_[1]");
}


sub local_cp
{
	system("cp -p $_[1] $_[2]");
}

sub rcp
{
	system("rcp -p $_[1] $_[0]:$_[2]");
}

sub scp
{
	system("scp -p $_[1] $_[0]:$_[2]");
}


sub local_chgrp
{
	system("chgrp $_[2] $_[1]");
}

sub rsh_chgrp
{
	system("rsh $_[0] chgrp $_[2] $_[1]");
}

sub ssh_chgrp
{
	system("ssh $_[0] chgrp $_[2] $_[1]");
}
